VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
  Persistable = 0  'NotPersistable
  DataBindingBehavior = 0  'vbNone
  DataSourceBehavior  = 0  'vbNone
  MTSTransactionMode  = 0  'NotAnMTSObject
END
Attribute VB_Name = "clsTimer"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Attribute VB_Ext_KEY = "SavedWithClassBuilder6" ,"Yes"
Attribute VB_Ext_KEY = "Top_Level" ,"Yes"
Option Explicit
  
Private Declare Function SetTimer Lib "user32" (ByVal hWnd As Long, ByVal nIDEvent As Long, ByVal uElapse As Long, ByVal lpTimerFunc As Long) As Long
Private Declare Function KillTimer Lib "user32" (ByVal hWnd As Long, ByVal nIDEvent As Long) As Long
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)
Private Declare Function GetTickCount Lib "kernel32" () As Long
Private Declare Function SetRectByt Lib "user32" Alias "SetRect" (lpRect As Long, ByRef X1 As Byte, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As Long
  
Private mlngTimerId As Long
Private mlngInterval As Long
Private mbytData(12) As Byte
  
Public Event Timer(ByVal dwTime As Long)
  
Public Sub TimerProc()
  RaiseEvent Timer(GetTickCount)
End Sub
  
Public Property Let Interval(ByVal NewVal As Long)
  
 mlngInterval = NewVal
  
 If Running Then Running = False
 
 If NewVal <> 0 Then Running = True
    
End Property
  
Public Property Get Interval() As Long
Interval = mlngInterval
End Property
  
Public Property Let Running(ByVal NewVal As Boolean)
If NewVal Then
  If mlngTimerId = 0 Then
    mlngTimerId = SetTimer(0&, 0&, mlngInterval, VarPtrByt(mbytData(0)))
    If mlngTimerId = 0 Then Err.Raise vbObjectError, "clsTimer.Running", "Timer failed to start."
  End If
Else
  If Not mlngTimerId = 0 Then
    If KillTimer(0&, mlngTimerId) = 0 Then Err.Raise vbObjectError + 1, "clsTimer.Running", "Timer failed to stop."
    mlngTimerId = 0
  End If
End If
End Property
  
Public Property Get Running() As Boolean
  Running = mlngTimerId <> 0
End Property
  
Private Sub Class_Initialize()
  Dim lngX As Long
    
  CopyMemory lngX, Me, 4                  'lngX=ObjPtr(me)
  mbytData(0) = &H68
  CopyMemory mbytData(1), lngX, 4         'push this (me) on stack
  mbytData(5) = &HE8
  CopyMemory mbytData(6), GetVTableAddress(Me, 7) - VarPtrByt(mbytData(10)), 4 'call TimerProc
  mbytData(10) = &HC2
  mbytData(11) = &H10
  mbytData(12) = &H0                      'ret 10   ---   return from callback, removing 4 parameters from stack
End Sub
  
Private Function VarPtrByt(ByRef bytRef As Byte) As Long
  Dim lngX(3) As Long 'Replacement for RECT structure
    
  SetRectByt lngX(0), bytRef, 0, 0, 0
  VarPtrByt = lngX(0)
End Function
  
Private Function GetVTableAddress(objRef As Object, Offset As Long) As Long
  Dim lngX As Long
    
  CopyMemory lngX, objRef, 4 'lngx=ObjPtr(Me)
  CopyMemory lngX, ByVal lngX, 4 'Get pointer to VTable
  CopyMemory GetVTableAddress, ByVal lngX + Offset * 4, 4 'Get function pointer
End Function
  
Private Sub Class_Terminate()
  Running = False 'Parar el Timer
  Erase mbytData
End Sub

